Opportunistic Exploration — Replication Data

The model we are using to fit the data

\[ p_{mult} = \frac{1}{1 + exp(\frac{R_{mult} - R_{add} + \alpha(I_{mult} - I_{add}) + D(M_{add} - M_{mult}) + B}{\sqrt2\sigma})} \]

Are the coefficients significantly different between the short and long horizons?

map2_dfr(
  c("greater", "less", "less"),
  c("difficulty", "information", "temp"),
  ~custom_compare_paired_fits(
  .x, paste0(.y, "_coef"), "replication", F, "rt", "percentile",
  "continuous", "Short horizon, free choice 1", "Long horizon, free choice 1",
  F, F, 0, Inf, "t.test"
  ) %>%
    mutate(coefficient = .y) %>%
    select(coefficient, estimate, statistic, p.value)
)

Coefficient estimates for long vs. short horizons for exploratory and replication data

map(
  c("difficulty", "information", "temp"),
  ~{
    
    my_aggregation = "percentile"
    my_coef = paste0(.x, "_coef")
    my_iv = "rt"

exploratory_short <- here("Analysis", "main_task", "fits.rds") %>%
  read_rds() %>%
  filter(
    batch == "exploratory",
    separate_by_exposure == F,
    iv == my_iv,
    aggregation == my_aggregation,
    continuum == "continuous",
    (free_choice_label == "Short horizon, free choice 1" & equal_exposure == F) |
      (free_choice_label == "Long horizon, free choice 1" & equal_exposure == F)
  ) %>%
  group_by(subid) %>%
  filter(
    min(total_mult_chosen) >= 3,
    max(total_trials - total_mult_chosen) >= 3
  ) %>%
  ungroup() %>%
  mutate(across(c(free_choice_trial), as_factor)) %>%
  arrange(subid, free_choice_label) %>%
  filter(free_choice_label == "Short horizon, free choice 1") %>%
  pull(!!my_coef)

exploratory_long <- here("Analysis", "main_task", "fits.rds") %>%
  read_rds() %>%
  filter(
    batch == "exploratory",
    separate_by_exposure == F,
    iv == my_iv,
    aggregation == my_aggregation,
    continuum == "continuous",
    (free_choice_label == "Short horizon, free choice 1" & equal_exposure == F) |
      (free_choice_label == "Long horizon, free choice 1" & equal_exposure == F)
  ) %>%
  group_by(subid) %>%
  filter(
    min(total_mult_chosen) >= 3,
    max(total_trials - total_mult_chosen) >= 3
  ) %>%
  ungroup() %>%
  mutate(across(c(free_choice_trial), as_factor)) %>%
  arrange(subid, free_choice_label) %>%
  filter(free_choice_label == "Long horizon, free choice 1") %>%
  pull(!!my_coef)

replication_short <- here("Analysis", "main_task", "fits.rds") %>%
  read_rds() %>%
  filter(
    batch == "replication",
    separate_by_exposure == F,
    iv == my_iv,
    aggregation == my_aggregation,
    continuum == "continuous",
    (free_choice_label == "Short horizon, free choice 1" & equal_exposure == F) |
      (free_choice_label == "Long horizon, free choice 1" & equal_exposure == F)
  ) %>%
  group_by(subid) %>%
  filter(
    min(total_mult_chosen) >= 3,
    max(total_trials - total_mult_chosen) >= 3
  ) %>%
  ungroup() %>%
  mutate(across(c(free_choice_trial), as_factor)) %>%
  arrange(subid, free_choice_label) %>%
  filter(free_choice_label == "Short horizon, free choice 1") %>%
  pull(!!my_coef)


replication_long <- here("Analysis", "main_task", "fits.rds") %>%
  read_rds() %>%
  filter(
    batch == "replication",
    separate_by_exposure == F,
    iv == my_iv,
    aggregation == my_aggregation,
    continuum == "continuous",
    (free_choice_label == "Short horizon, free choice 1" & equal_exposure == F) |
      (free_choice_label == "Long horizon, free choice 1" & equal_exposure == F)
  ) %>%
  group_by(subid) %>%
  filter(
    min(total_mult_chosen) >= 3,
    max(total_trials - total_mult_chosen) >= 3
  ) %>%
  ungroup() %>%
  mutate(across(c(free_choice_trial), as_factor)) %>%
  arrange(subid, free_choice_label) %>%
  filter(free_choice_label == "Long horizon, free choice 1") %>%
  pull(!!my_coef)


bind_rows(
  tibble(
    x = "exploratory_short",
    y = exploratory_short
  ),
  
  tibble(
    x = "exploratory_long",
    y = exploratory_long
  ),
  
  tibble(
    x = "replication_short",
    y = replication_short
  ),
  
  tibble(
    x = "replication_long",
    y = replication_long
  )
) %>%
  ggplot(aes(x = x, y = y)) +
  geom_violin() +
  geom_jitter(width =.1) +
  geom_boxplot(width = .1, outlier.shape = NA) +
  theme(legend.position = "none") +
  labs(
    title = .x,
    x = "",
    y = "Coefficent Estimate per Participant"
  )
  }
) %>%
  reduce(`/`)

analysis_combos <- expand.grid(
  pair_compairison = c("greater", "less"),
  coef_of_interest = c("difficulty_coef", "information_coef", "temp_coef"),
  keep_batch = c("exploratory", "replication"),
  keep_separate_by_exposure = F,
  keep_iv = c("rt", "difficulty"),
  keep_aggregation = c("raw", "percentile"),
  keep_continuum = "continuous",
  group_1 = "Short horizon, free choice 1",
  group_2 = "Long horizon, free choice 1",
  min_duration = c(0),
  max_duration = c(Inf),
  type_of_test = c("t.test", "wilcox.test")
) %>%
  mutate(
    group_1_exposure = keep_separate_by_exposure,
    group_2_exposure = keep_separate_by_exposure
  ) %>%
  filter(max_duration > min_duration) %>%
  filter(
    (coef_of_interest == "difficulty_coef" &  pair_compairison == "greater") |
      coef_of_interest != "difficulty_coef" & pair_compairison == "less") %>%
  relocate(type_of_test, .after = last_col()) %>%
  mutate(across(where(is.factor), as.character))

map_dfr(1:nrow(analysis_combos), ~{
  arow <- analysis_combos %>% filter(row_number() == .x)
  
  brow <- custom_compare_paired_fits(
    arow$pair_compairison, arow$coef_of_interest, arow$keep_batch,
    arow$keep_separate_by_exposure, arow$keep_iv, arow$keep_aggregation,
    arow$keep_continuum, arow$group_1, arow$group_2, arow$group_1_exposure,
    arow$group_2_exposure, arow$min_duration, arow$max_duration,
    arow$type_of_test
  )
  
  bind_cols(arow, brow)
  
}) %>%
  arrange(coef_of_interest, keep_batch, -p.value) %>%
  mutate(across(p.value, ~insight::format_p(.x))) %>%
  select(coef_of_interest, keep_batch, p.value, keep_iv, keep_aggregation, type_of_test) %>%
  rename_with(~str_replace_all(.x, "keep_", " "), starts_with("keep_"))

Maybe we should be more vigilant of how long tasks are taking participants?

It doesn’t appear that participants who finish the task quickly are particularly driving the null results (i.e., their coefficient isn’t particulaly large).

map(
    c("max_time_elapsed", "median_choice_time"),
    function(desired_x_axis){
        map(c("exploratory", "replication"), ~
                custom_compare_paired_fits(
                    "greater", "difficulty_coef", .x, F, "rt", "percentile",
                    "continuous", "Short horizon, free choice 1", "Long horizon, free choice 1",
                    F, F, 0, Inf, "t.test", F
                ) %>%
                mutate(difficulty_coef_diff = difficulty_coef_Long - difficulty_coef_Short) %>%
                filter(max_time_elapsed < 100) %>%
                ggplot(aes(!!sym(desired_x_axis), difficulty_coef_diff)) +
                geom_smooth() +
                geom_point() +
                labs(
                    title = paste(
                        .x,
                        "batch,",
                        ifelse(
                            desired_x_axis == "max_time_elapsed",
                            "experiment duration (including instrc)",
                            "average free choice RT"
                        )
                        ),
                    x = ifelse(
                            desired_x_axis == "max_time_elapsed",
                            "Minutes taken to go through entire task",
                            "Average time to make a free choice (in seconds)"
                        ),
                    y = "Difficulty Coefficient"
                )
        ) %>%
            reduce(`/`)
    }
) %>% reduce(`|`)

Average amount of time spent on a free choice, over the course of the task (excluding 32 trials that lasted longer than 2 minutes)

free_choice_df %>%
  mutate(choice_time = choice_time / (60 * 1000)) %>%
  filter(choice_time < 2) %>%
  ggplot(aes(overall_trial, choice_time)) +
  geom_smooth()

Some participants took a massive amount of time (breaks) to complete some of the trials

trials_following_massive_delays

But modeling the results without these participants doesn’t make our results any more significant

custom_compare_paired_fits(
                    "greater", "difficulty_coef", "replication", F, "rt", "percentile",
                    "continuous", "Short horizon, free choice 1", "Long horizon, free choice 1",
                    F, F, 0, Inf, "t.test", T, pcpts_taking_massive_delays
                ) %>%
  pull(p.value)

## [1] 0.05654418

However, if we keep the data from all participants and filter each of these participants by how far along they were in the task, the replication data look more promising

tribble(
  ~"First_x_Trials", ~"Exploratory", ~"Replication",
  20,                0.05671,        0.4849,
  40,                1.053e-05,      0.002351,
  60,                2.019e-05,      0.03906,
  80,                2.729e-07,      0.05509
)

Choice Curves (for replication data)

How much harder mult is than add side and likelihood of choosing mult

Difficulty is measured here by raw baseline RT

input <- list()

input$batch_choice_curve <- "replication"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "raw" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "rt" # rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # F

choice_and_learning_plots("choice_curve")

Difficulty is measured here by raw baseline self-rated difficulty

input$batch_choice_curve <- "replication"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "raw" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "difficulty" # rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # F

choice_and_learning_plots("choice_curve")

Next two plots are same as previous two, except difficulty has been scaled between 1-100 rather than being in raw units

Difficulty is measured here by scaled baseline RT

input$batch_choice_curve <- "replication"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "percent" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "rt" # rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # F

choice_and_learning_plots("choice_curve")

Difficulty is measured here by scaled baseline self-rated difficulty

input$batch_choice_curve <- "replication"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "percent" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "difficulty" # rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # F

choice_and_learning_plots("choice_curve")

Probability of choosing mult based on how much more or less rewarding (in points) it’s been, compared to addition side

input$batch_choice_curve <- "replication"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # mult accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "raw" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # mult rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "rew_exposed_cum_mean" # rt rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # T F
choice_and_learning_plots("choice_curve")

Choice Curves (for exploratory data)

How much harder mult is than add side and likelihood of choosing mult

Difficulty is measured here by raw baseline RT

input <- list()

input$batch_choice_curve <- "exploratory"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "raw" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "rt" # rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # F

choice_and_learning_plots("choice_curve")

Difficulty is measured here by raw baseline self-rated difficulty

input$batch_choice_curve <- "exploratory"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "raw" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "difficulty" # rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # F

choice_and_learning_plots("choice_curve")

Next two plots are same as previous two, except difficulty has been scaled between 1-100 rather than being in raw units

Difficulty is measured here by scaled baseline RT

input$batch_choice_curve <- "exploratory"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "percent" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "rt" # rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # F

choice_and_learning_plots("choice_curve")

Difficulty is measured here by scaled baseline self-rated difficulty

input$batch_choice_curve <- "exploratory"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "percent" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "difficulty" # rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # F

choice_and_learning_plots("choice_curve")

Probability of choosing mult based on how much more or less rewarding (in points) it’s been, compared to addition side

input$batch_choice_curve <- "exploratory"   # "exploratory" "replication"
input$y_var_choice_curve <- "mult" # mult accuracy bigger_rand bigger_side bigger_rew_exposed_cum_mean bigger_rew_exposed_cum_count bigger_rew_latent bigger_rew_exposed_cum_sd
input$x_raw_or_percent <- "raw" # raw percent
input$choice_combos_choice_curve <- c("Long horizon, free choice 1", "Short horizon, free choice 1") # "Short horizon, free choice 1" "Long horizon, free choice 1"  "Long horizon, free choice 2"  "Long horizon, free choice 3"  "Long horizon, free choice 4"  "Long horizon, free choice 5"
input$x_comparison_group <- "mult" # mult rew_exposed_cum_sd rew_exposed_cum_mean rew_latent side rand
input$x_comparison_dimension <- "rew_exposed_cum_mean" # rt rew_exposed_cum_mean rew_latent difficulty rand rew_exposed_cum_sd
input$show_CI_choice_curve <- T # T F
choice_and_learning_plots("choice_curve")